perm filename LOOP.FAI[XX,LCS]15 blob
sn#222543 filedate 1976-06-29 generic text, type T, neo UTF8
00100 TITLE LOOP ; SUBROUTINE LOOP(I,J,L,M,N)
00200 ENTRY LOOP,FINDIT,PLACE,DPYNEW,MVBEAM,MVBX,JUGGLE,XNOTE,BAUTO
00300 ENTRY SORT2,UPDATE,NEWR,MSSLUP,LUP2,HOMER,FSCAN,NALF,BOX
00400 EXTERNAL ACCPOG,DPYOUT,.COMM.,XRN,AMOD,PTR,KJY,DPY,DL,SCM
00500 EXTERNAL SC,SCX,RRJJ,STF,ALF,POSI,RMOD,RINP,SIZ
00600 EXTERNAL RHORZ,SETCUR,DPYSET,DPYBRT,SETPOG,ALINE
00700 DEFINE FIXX(N)
00800 < KIFIX N,N ↔ > ; NEW KL10 FIX
01400 ; DIMENSION N(1)
01500 MM←1 ↔ NN←2 ↔ JK←3 ↔JT←4 ↔IEND←5 ↔A←6 ↔K←7↔ IS←10↔ IZ←11↔ R←12↔ L←13
01600 RC←14 ↔ NX←15 ;**** AC'S 0,1,2,3,5 ARE USED IN 'PLACE' & 'FINDIT'!!
01700 LOOP: 0 ; DO 1 NN=I+L,J+L,K
01800 MOVE 1,@4(16)
01900 SUB 1,@3(16) ; MM IS IN 1
02000 MOVE 2,@(16)
02100 ADD 2,@3(16) ;I+L -- NN, 1ST TIME
02200 MOVE 3,@1(16)
02300 ADD 3,@3(16) ;J+L
02400 MOVE 4,@2(16) ;K
02500 HRRZI 5,@5(16) ; ADR. OF N
02600 ADDI 2,-1(5) ; N(NN)
02700 ADDI 3,-1(5)
02800 JUMPL 4,LP3 ; JUMP IF NEG. INCR.
02900 HRRM 1,.+1 ; ADD IN MM
03000 LP1: MOVE 6,(2)
03100 MOVEM 6,(2) ;N(NN)=N(NN+MM)
03200 CAIGE 2,(3)
03300 AOJA 2,LP1
03400 JRA 16,6(16)
03500 LP3: HRRM 1,.+1
03600 LP2: MOVE 6,(2) ;NEG. INCR.
03700 MOVEM 6,(2)
03800 CAILE 2,(3)
03900 SOJA 2,LP2
04000 JRA 16,6(16) ; END
04100
04200 PLACE: 0 ; FUNCTION PLACE(X)
04300 ; COMMON R2,JA,CENTR,J2,RJQ(20),JQ(20)/XRN/RN(4000)
04400 ; EQUIVALENCE (R11,RJQ(9)),(RD,RN(4000))
04500 MOVN 2,@(16) ; PLACE=R11-ABS(RD-X)
04600 FADR 2,RMOD+=9 ;END
04700 MOVMS 2
04800 MOVE 0,.COMM.+=12 ;R11
04900 FSBR 0,2
05000 JRA 16,1(16)
05100
05200 FINDIT: 0 ; FUNCTION FINDIT(N)
05300 SETZ ; COMMON R2,JA,CENTR,J2,RJQ(20),JQ(20)
05400 HRRZ 1,@(16) ; COMMON /XRN/RN(4000) /PTR/PWDS(250),ITEM,L,I,IX
05500 ;; HRRZI 2,PTR ; FINDIT=0
05600 ;; ADDI 1,(2) ; L=PWDS(N)
05700 ;; MOVE 2,-1(1) ; IF(RN(L+1).NE.1)GO TO 377
05800 ;; FIXX(2) ; IF(RN(L+2).EQ.R2)RETURN
05900 ;; HRRZI 3,XRN ;377 FINDIT=-1
06000 ;; ADDI 3,(2) ; END
06100 ;; MOVE 5,(3) ; RN(L+1)
06200 MOVE 2,PTR-1(1) ;THESE 3 REPLACE ABOVE
06300 ;X FIXX(2)
06400 MOVE 5,XRN(2)
06500 CAME 5,[1.0]
06600 JRST FNEG
06700 MOVEM 2,PTR+=251 ; SENDS BACK A NUM IN L
06800 ;; MOVE 5,1(3) ;RN(L+2)
06900 MOVE 5,XRN+1(2)
07000 CAME 5,.COMM.
07100 FNEG: SETO
07200 JRA 16,1(16)
07300
07400 DPYNEW: 0 ; SUBROUTINE DPYNEW
07500 JSA 16,ACCPOG ; COMMON/DPY/ST(4000),WDS(250),MEDIT,IGO
07600 JUMP [1] ; CALL ACCPOG(1)
07700 MOVE 2,DPY+=4251 ; IF(IGO.GT.0)RETURN
07800 JUMPG 2,DB ; CALL DPYOUT(1)
07900 JSA 16,DPYOUT ; END
08000 JUMP [1]
08100 DB: JRA 16,(16)
08200
08300 MVBEAM: 0 ;C THESE MOVE ENDS OF PARTIAL INNER BEAMS.
08400 HRRZ 2,(16) ; SUBROUTINE MVBEAM(R,I,JY,L,W)
08500 MOVE 5,@1(16) ; I
08600 ADD 2,5 ;C L AND JY ARE FOR MOVES TO DIFF. STAFF.
08700 ADD 2,@2(16) ; DIMENSION R(1)
08800 MOVE 3,-1(2) ; Y=R(JY+I)
08900 MOVM 4,3 ; Z=ABS(Y)
09000 CAMGE 4,[=100.0] ; IF(Z.LT.100.)GO TO 1
09100 JRST MV1
09200 CAML 5,[6]
09300 JRST MV1 ; IF(I.GT.5)GO TO 1
09400 ;C NEXT FOR MINIS, DIAMONDS, 'X' NOTES. (LIMIT OF +-99 ON ALTITUDE.)
09500 JSA 16,AMOD ; Y=AMOD(Y,100.)
09600 JUMP 3
09700 JUMP [=100.0] ; 0 HAS Y
09800 MOVE 5,@4(16) ; X=Y+W
09900 FADR 5,0
10000 MOVM 6,5 ; Z=Z-ABS(Y)+ABS(X)
10100 MOVMS 0 ;C PUTS ALL INTO POSITIVE
10200 FSBR 4,0
10300 FADR 4,6
10400 SKIPGE 5 ; IF(X)Z=-Z
10500 MOVNS 4 ; Z
10600 JRST MV2 ; GO TO 2
10700 MV1: FADR 3,@4(16) ;1 Z=Y+W
10800 MOVE 4,3 ; Z NOW IN 4
10900 MV2: HRRZI 3,@(16) ;2 R(L+I)=Z
11000 ADD 3,@3(16)
11100 ADD 3,@1(16)
11200 MOVEM 4,-1(3) ; PUT IT IN R(L+I)
11300 JRA 16,5(16) ; END
11400
11500 MVBX: 0 ; SUBROUTINE MVBX(I)
11600 ; COMMON R2,JA,CENTR,J2,RJQ(20),L,RDIS,JQ(18)/KJY/K,JY/XRN/R(4000)
11700 MOVE 2,@(16) ; EQUIVALENCE (R4,RJQ(2)),(R8,RJQ(6))
11800 ADD 2,KJY+1 ; R(L+I)=R8+(R(JY+I)-R4)*RDIS
11900 ;; HRRZI 4,XRN
12000 ;; ADDI 2,(4)
12100 ;; MOVE 3,-1(2) ; R(JY+I)
12200 MOVE 3,XRN-1(2)
12300 FSBR 3,.COMM.+5
12400 FMPR 3,.COMM.+=25 ; *RDIS
12500 FADR 3,.COMM.+=9 ; +R8
12600 MOVE 2,@(16)
12700 ADD 2,.COMM.+=24 ; + L
12800 ;; ADDI 2,(4)
12900 ;; MOVEM 3,-1(2) ;R(L+I)
13000 MOVEM 3,XRN-1(2)
13100 JRA 16,1(16)
13200
13300 JUGGLE: 0 ; SUBROUTINE JUGGLE
13400 ; IMPLICIT INTEGER(A-Z)
13500 ; REAL PWDS,RN
13600 ; COMMON /DL/X22,SAVER,NAME /XRN/RN(4000)
13700 ; COMMON/PTR/PWDS(250),ITEM,L,I,IX/DPY/ST(4000),WDS(250),MEDIT,IGO
13800 SOS PTR+=250 ;ITEM=ITEM-1
13900 HRRZI 15,XRN ; JX=RN(MEDIT)+3 WD CNT OF OLD ITEM
14000 ;C I-IX IS WD CNT OF NEW ITEM
14100 ADD 15,DPY+=4250
14200 KIFIX 14,-1(15) ;MOVE 14,-1(15)
14300 ;; FIXX(14)
14400 ADDI 14,3 ; JX
14500 MOVE 13,PTR+=253 ;JY=IX
14600 MOVE 11,PTR+=252 ; I
14700 SUB 11,13
14800 SUB 11,14 ;Z=I-IX-JX SPACE CHANGE
14900 JUMPL 11,J2751 ;IF(Z)2751,172,751
15000 JUMPE 11,J172
15100 MOVE 5,PTR+=252 ;751 CALL LOOP(I-1,MEDIT+JX,-1,Z,0,RN)
15200 SUBI 5,1
15300 MOVE 10,DPY+=4250
15400 ADD 10,14
15500 JSA 16,LOOP
15600 JUMP 5
15700 JUMP 10
15800 JUMP [-1]
15900 JUMP 11
16000 JUMP [0]
16100 JUMP XRN
16200 ADD 13,11 ;JY=IX+Z
16300 JRST J172 ;GO TO 172
16400 J2751: ADD 14,DPY+=4250 ;2751 CALL LOOP(MEDIT+JX+Z,IX+Z-1,1,0,-Z,RN)
16500 ADD 14,11
16600 MOVE 5,11
16700 ADD 5,PTR+=253
16800 SOJ 5,
16900 MOVN 10,11
17000 JSA 16,LOOP
17100 JUMP 14
17200 JUMP 5
17300 JUMP [1]
17400 JUMP [0]
17500 JUMP 10
17600 JUMP XRN
17700 ;172 J=RN(JY)+2
17900 J172: KIFIX 12,XRN-1(13) ;MOVE 12,XRN-1(13)
18000 ;; MOVE 12,-1(12) ;RN(JY)
18100 ;;; FIXX(12)
18200 ADDI 12,2 ; J IS IN 12
18300 JSA 16,LOOP ;CALL LOOP(0,J,1,MEDIT,JY,RN)
18400 JUMP [0]
18500 JUMP 12
18600 JUMP [1]
18700 JUMP DPY+=4250 ; MEDIT
18800 JUMP 13 ; JY
18900 JUMP XRN
19000 MOVE 12,PTR+=253 ; I=IX+Z
19100 ADD 12,11 ; Z IS IN 11
19200 MOVEM 12,PTR+=252
19300 MOVE 12,PTR+=250 ; 1751 X=ITEM+1
19400 AOJ 12, ; X IS IN 12
19500 HRRZI 13,DPY+=4000 ; JX=WDS(X22+1)-WDS(X22)
19600 ADD 13,DL
19700 MOVE 14,(13) ; WDS(X22+1) IN 14 ADR. WDS(X22) IN 13
19800 SUB 14,-1(13) ;JX IN 14
19900 HRRZI 10,DPY+=4000 ; J=WDS(X+1)-WDS(X)
20000 ADDI 10,(12)
20100 MOVE 7,(10) ;WDS(X+1)
20200 SUB 7,-1(10) ;J IN 7
20300 MOVEM 7,MVBX ; STORE J
20400 SUB 7,14 ; Y=J-JX
20500 MOVE 14,-1(10) ; JX=WDS(X)+Y+1
20600 ADD 14,7
20700 AOJ 14, ; JX IN 14
20800 JUMPL 7,J2851 ; IF(Y)2851,182,282
20900 JUMPE 7,J182
21000 MOVE 15,(10) ;282 CALL LOOP(WDS(X+1)+2,WDS(X22),-1,Y,0,ST)
21100 ADDI 15,2 ; ARG 1
21200 MOVE 6,-1(13) ; ARG 2
21300 JSA 16,LOOP
21400 JUMP 15
21500 JUMP 6
21600 JUMP [-1]
21700 JUMP 7 ; Y
21800 JUMP [0]
21900 JUMP DPY
22000 JRST J182 ; GO TO 182
22100 J2851: MOVE 14,(13) ;2851 CALL LOOP(WDS(X22+1)+Y+1,WDS(X)+Y+1,1,0,-Y,ST)
22200 ADD 14,7 ;+Y
22300 ADDI 14,1 ; ARG 1
22400 MOVE 5,-1(10) ;WDS(X)
22500 ADD 5,7
22600 ADDI 5,1 ; ARG 2
22700 MOVNM 7,MVBEAM ; -Y IS STORED
22800 JSA 16,LOOP
22900 JUMP 14
23000 JUMP 5
23100 JUMP [1]
23200 JUMP [0]
23300 JUMP MVBEAM
23400 JUMP DPY
23500 MOVE 14,-1(10) ; WDS(X) JX=WDS(X)+1
23600 ADDI 14,1 ; JX IN 14
23700 J182: MOVE 5,-1(13) ;182 CALL LOOP(1,J,1,WDS(X22)+1,JX,ST)
23800 ADDI 5,1 ;WDS(X22)+1
23900 JSA 16,LOOP
24000 JUMP [1]
24100 JUMP MVBX
24200 JUMP [1]
24300 JUMP 5
24400 JUMP 14
24500 JUMP DPY
24600 MOVE 2,DL ; DO 183 K=X22+1,X
24700 ;; HRRZI 5,DPY+=4000 ; 183 WDS(K)=WDS(K)+Y
24800 ;; ADD 5,2
24900 HRRZI 3,PTR
25000 ADDI 3,(2)
25100 ;; TLC 11,232000 ; FLOAT Z
25200 ;; FADR 11,11
25300 J183: JUMPE 11,J184 ;IF(Z.EQ.0)GO TO 184
25400 ADDM 11,(3) ; PWDS(K)=PWDS(K)+Z
25500 AOJ 3, ;UPDATE PWDS AND WDS
25600 J184: JUMPE 7,J185
25700 ADDM 7,(13)
25800 AOJ 13,
25900 J185: CAIGE 2,(12)
26000 AOJA 2,J183
26100 ;; HRRZI 2,DPY+=4000 ;ST(2)=WDS(X)
26200 ;; ADDI 2,(12) ;WDS(X+1) ADR.
26300 ;; MOVE 2,-1(2)
26400 MOVE 2,DPY+=3999(12)
26500 ;; HRRZI 3,DPY
26600 ;; MOVEM 2,1(3)
26700 MOVEM 2,DPY+1
26800 SETZM DL ;X22=0
26900 JRA 16,(16)
27000
27100 SORT2: 0 ;SUBROUTINE SORT2(RPOS,M)
27200 MOVEI 2,2 ;DIMENSION RPOS(2,200)
27300 S3: MOVE 6,2 ;(K=L HERE)
27400 SETO 11, ;L=2
27500 HRRZI 3,@(16) ;3 J=-1
27600 MOVE 4,2 ;RX=RPOS(1,L-1)
27700 SUBI 4,1 ;L-1
27800 IMULI 4,2
27900 ADDI 4,(3)
28000 MOVE 5,-2(4) ;RX
28100 S2: MOVE 7,6 ; DO 2 K=L,M
28200 ;; LSH 7,1 ;IF(RPOS(1,K).GE.RX)GO TO 2
28300 IMULI 7,2 ;IF(RPOS(1,K).GE.RX)GO TO 2
28400 ADDI 7,(3)
28500 CAMG 5,-2(7)
28600 JRST S1 ; CONTINUE
28700 MOVE 5,-2(7) ; RX=RPOS(1,K)
28800 ;;C WHY WERE ALL THE RX'S JX ????? 9/6/73
28900 MOVE 11,6 ;J=K
29000 S1: CAMGE 6,@1(16) ;2 CONTINUE
29100 AOJA 6,S2
29200 JUMPL 11,S4 ;IF(J)GO TO 4
29300 MOVE 12,2 ;K=L-1
29400 SOS 12
29500 IMULI 12,2 ;(K*2)
29600 ADD 12,3 ;CALL EXCH(RPOS(1,K),RPOS(1,J))
29700 MOVE 10,-2(12)
29800 ;; LSH 11,1 ;MULTS BY 2 (LEFT SHIFT)
29900 IMULI 11,2
30000 ADD 11,3
30100 EXCH 10,-2(11)
30200 MOVEM 10,-2(12)
30300 MOVE 10,-1(12) ;CALL EXCH(RPOS(2,K),RPOS(2,J))
30400 EXCH 10,-1(11)
30500 MOVEM 10,-1(12)
30600 S4: CAMGE 2,@1(16) ;4 L=L+1
30700 AOJA 2,S3 ;IF(L.LE.M)GO TO 3
30800 JRA 16,2(16) ;END
30900
31000 XNOTE: 0 ;FUNCTION XNOTE(J)
31100 MOVE 3,@(16) ;COMMON/XRN/RN(4000)
31200 IMULI 3,12 ;DIMENSION R(10,80)
31300 ;; ADDI 3,XRN+=2993 ;EQUIVALENCE (R,RN(3001))
31400 ;; MOVE 2,(3) ;XNOTE=AMOD(R(4,J),100.)
31500 MOVE 2,RINP-7(3)
31600 JSA 16,AMOD
31700 JUMP 2
31800 JUMP [=100.0]
31900 JRA 16,1(16) ;END
32000
32100 BAUTO: 0 ; SUBROUTINE BAUTO(J,L,K,N)
32200 ;C FOR AUTOMATIC BEAMS.
32300 MOVEI 2,2 ;COMMON/SCM/V(78),I,LCNT,STAFF,LIST(200),REND
32400 ADDB 2,@(16) ;J=J+2
32500 ;; MOVE 3,@3(16)
32600 MOVE 4,@1(16)
32700 SUB 4,@3(16) ;L-N
32800 MOVE 5,@2(16)
32900 SUB 5,@3(16) ;K-N
33000 ;; HRRZI 6,SCM
33100 ;; ADDI 6,(2)
33200 FLTR 4,4 ;TLC 4,232000
33300 ;; FADR 4,4 ;FLOATS IT
33400 MOVEM 4,SC+16(2) ;VX(J-1)=L-N
33500 ;; MOVEM 4,SCM-2(2) ****** WAS V(J-1)
33600 ;**** A LIMIT OF 25 BEAMS PER LINE.
33700 FLTR 5,5 ;TLC 5,232000
33800 ;; FADR 5,5 ;FLOATS IT
33900 MOVEM 5,SC+17(2) ;VX(J)=K-N
34000 ;; MOVEM 5,SCM-1(2)
34100 JRA 16,4(16)
34200
34300 UPDATE: 0 ; SUBROUTINE UPDATE(I)
34400 ;; HRRZI 3,XRN ;COMMON /PTR/PWDS(250),ITEM,LL,IS,IX /XRN/RN(4000)
34500 ;; ADD 3,PTR+=252 ;RN(IS)=I
34600 MOVE 3,PTR+=252
34700 FLTR 2,@(16) ;MOVE 2,@(16)
34800 ;; TLC 2,232000 ;FLOAT I
34900 ;; FADR 2,2
35000 ;; MOVEM 2,-1(3)
35100 MOVEM 2,XRN-1(3)
35200 ;; MOVE 2,PTR+=252
35300 ;; ADD 2,@(16)
35400 ;; ADDI 2,3
35500 ;; MOVEM 2,PTR+=252 ;IS=IS+I+3
35600 MOVE 2,@(16)
35700 ADDI 2,3
35800 ADDM 2,PTR+=252
35900 JRA 16,1(16)
36000
36100 IK: 0 ;***** DON'T USE THESE ELSEWHERE, THEY STORE NUMBS.!!
36200 JIT: 0 ; THESE ARE TO STORE PNTRS IN LOOP
36300 NEWR: 0 ; SUBROUTINE NEWR
36400 MOVE A,SC+=70 ;COMMON/PTR/PWDS(250),ITEM,LL,IS,IX
36500 CAIE A,1 ;COMMON/XRN/RN(4000)
36600 JRST N1 ;COMMON/SCM/V(78),I,LCNT,STAFF,LIST(200),REND
36700 MOVE JK,PTR+=252;COMMON/SCX/RHY(4),JALPHA(30),JX,U,JZ,IRHY,J4,KA,KB,IZ
36800 MOVEM JK,IK ;1 /SC/J,L,MK,ISKP,XMINUS,N,IEXP,LK,NNUM,JJ,JA,DBST,NFLG
36900 MOVE JT,PTR+=250 ;1 ,IXX,ISEMI,IQT,VX(50),IAMP,K,KN,M,MODE,IBLA
37000 MOVEM JT,JIT ;DIMENSION R(10,80)
37100 N1: MOVE IS,IK ;EQUIVALENCE (R,RN(3001))
37200 MOVEM IS,PTR+=252
37300 MOVE 14,[9999.0]
37400 MOVE JT,JIT ;IF(MODE.NE.1)GO TO 1
37500 ADDI JT,1 ;IK=IS
37600 MOVEM JT,PTR+=250 ;HOMER=ITEM
37700 MOVEI K,=10 ;1 IS=IK
37800 MOVE IZ,SCX+=41 ;ITEM=HOMER+1 ******************** WAS +=33
37900 IMULI IZ,=10 ;MODE 1=NOTE, 2=RHYTH, 3=ACCENTS, 4=BEAMS, 5=SLURS.
38000 ;;N2: HRRZI R,XRN+=2997 ;DO 2 K=1,IZ
38100 ;;;;N2: MOVE R,XRN+=2997(K) ;DO 2 K=1,IZ
38200 ;; ADD R,K ;IF(R(8,K).EQ.9999.)GO TO 2
38300 ;; MOVE R,(R)
38400 ;;;; CAMN R,[=9999.0]
38500 N2: CAMN 14,RINP-3(K)
38600 JRST NN2 ;SKIPS INVIS RESTS - ONLY NEEDED IN RHYTH.
38700 SETO IEND, ;C JUMP FOR BEAM CONT.
38800 ;; HRRZI L,XRN ;IEND=-1
38900 ;; ADD L,PTR+=252 ;RN(IS+3)=0
39000 ;; SETZM 2(L)
39100 ;; SETZM 1(L) ;RN(IS+2)=0
39200 MOVE L,PTR+=252
39300 SETZM XRN+2(L)
39400 SETZM XRN+1(L)
39500 MOVEI L,=10 ;C ↑↑↑↑ TO CLEAR ARRAY FOR SHORT ITEMS (CLEFS)
39700 N3: HRRZI R,RINP(K) ;DO 3 L=10,1,-1
39800 ;; ADDI R,(K) ;A=R(L,K)
39900 ADDI R,(L)
40000 MOVE A,-13(R) ;(OCTAL)=-11
40100 JUMPGE IEND,NX4 ;IF(A.NE.0)GO TO 77
40200 JUMPN A,NX3 ;IF(IEND)GO TO 3
40300 JRST NN3
40400 NX3: MOVE IEND,L ;77 IF(IEND)IEND=L
40500 ;;NX4: HRRZI R,XRN
40600 ;; ADD R,PTR+=252 ;RN(IS+L)=A
40700 ;; ADDI R,(L)
40800 ;; MOVEM A,-1(R)
40900 NX4: MOVE R,PTR+=252
41000 ADDI R,(L)
41100 MOVEM A,XRN-1(R)
41200 NN3: CAILE L,1 ;3 CONTINUE
41300 SOJA L,N3
41400 CAIGE IEND,3
41500 MOVEI IEND,3
41600 MOVE 15,IEND ;IF(IEND.LT.3)IEND=3
41700 SUBI 15,2
41800 JSA 16,UPDATE ;CALL UPDATE(IEND-2)
41900 JUMP 15
42000 NN2: CAML K,IZ ;2 CONTINUE
42100 JRA 16,(16) ;END
42200 ADDI K,=10
42300 JRST N2
42400
42500 CNT: 0
42600 MSSLUP: 0
42700 SETZ 1, ;161 CNT=1
42800 SETZ 2,
42900 L5543: MOVE 3,.COMM.+4(2) ;DO 5543 K=1,9
43000 ;; ADDI 3,(2)
43100 ;; MOVE 3,(3) ;RA=RJQ(K)
43200 SKIPE 3 ;IF(RA.NE.0)CNT=K
43300 MOVE 1,2
43400 ;; MOVEI 4,RRJJ+1 ;5543 RJJ(K)=RA
43500 ;; ADDI 4,(2)
43600 ;; MOVEM 3,(4)
43700 MOVEM 3,RRJJ+1(2)
43800 CAIG 2,7 ; LOOP BACK?
43900 AOJA 2,L5543
44000 AOJ 1,
44100 MOVEM 1,CNT ;REMEMBERS CNT
44200 JRA 16,(16)
44300
44400 LUP2: 0
44500 ;; MOVEI 1,XRN ;261 RN(I)=CNT
44600 ;; ADD 1,PTR+=252
44700 FLTR 2,CNT ;MOVE 2,CNT
44800 ;; TLC 2,232000
44900 ;; FADR 2,2 ;FLOATS IT
45000 ;; MOVEM 2,-1(1)
45100 MOVE 1,PTR+=252
45200 MOVEM 2,XRN-1(1)
45300 FLTR 2,.COMM.+1 ;MOVE 2,.COMM.+1 ;RN(I+1)=JA
45400 ;; TLC 2,232000
45500 ;; FADR 2,2
45600 ;; MOVEM 2,(1)
45700 ;; MOVE 2,PTR+=252 ;I=I+2
45800 ;; ADDI 2,2
45900 ;; MOVEM 2,PTR+=252
46000 MOVEM 2,XRN(1)
46100 ADDI 1,2
46200 MOVEM 1,PTR+=252
46300 MOVE 3,.COMM. ;RN(I)=R2
46400 ;; MOVEM 3,1(1)
46500 MOVEM 3,XRN-1(1)
46600 ;; NOT USED NOW! IF(RD.NE.0)RN(I)=RD
46700 ;;C TO SAVE NOTE NUMBS IN P2.
46800 SETZ 5, ;DO 4554 K=1,CNT
46900 L4554: MOVE 2,.COMM.+4(5)
47000 ;;L4554: MOVEI 2,.COMM.+4 ;(RJQ)
47100 ;; ADDI 2,(5)
47200 ;; MOVE 2,(2)
47300 ;; MOVEI 3,XRN(5)
47400 ;; ADDI 3,(5)
47500 ;; ADD 3,PTR+=252
47600 ;; MOVEM 2,(3) ;4554 RN(I+K)=RJQ(K)
47700 MOVE 3,1
47800 ADDI 3,(5)
47900 MOVEM 2,XRN(3)
48000 AOJ 5,
48100 CAME 5,CNT
48200 JRST L4554
48300 AOJ 5,
48400 ;; ADD 5,PTR+=252
48500 ADDM 5,PTR+=252
48600 ;; MOVEM 5,PTR+=252 ;3554 I=CNT+1+I
48700 JRA 16,(16)
48800
48900 ;;C****** FOR 'HOMING' OF BEAMS AND CHORD NOTES ***********
49000 ;; SUBROUTINE HOMER
49100 ;; IMPLICIT INTEGER(A-Q,S-Z)
49200 ;; REAL PWDS,DISX,A,B,PLACE,STFF
49300 ;; COMMON /STF/RSTFAC(-3/4),RSTJ2
49400 ;; COMMON R2,JA,CENTR,J2,RJQ(20),JQ(20) /POSI/STFF(-3/4),JJ2,POS
49500 ;; COMMON /XRN/RN(4000) /PTR/PWDS(250),ITEM,L,I,IX
49600 ;; COMMON/ALF/QQ(3),K,RA,RB,N,RG,M,X,RE,RF,A,B,DISX,INP(58)
49700 ;; EQUIVALENCE (R3,RJQ(1)),(R6,RJQ(4)),(J11,JQ(9)),(RD,RN(4000))
49800 ;; 1,(R7,RJQ(5)),(R9,RJQ(7)),(R11,RJQ(9)),(R13,RJQ(11))
49900 ;; 1,(J10,JQ(8)),(R8,RJQ(6)),(J7,JQ(5))
50000 HOMER: 0 ; IF(JA.EQ.6)GO TO 9
50100 MOVE MM,.COMM.+1
50200 CAIN MM,6
50300 JRST H9
50400 SKIPE .COMM.+=14 ;IF(R13.NE.0)GO TO 10
50500 JRST H10 ; FOR GENL HOMING; WORDS; BEAMS; STEMS;
50600
50700 ; ALF+=14= IS = WIDTH OF NOTE -- NEEDED BECAUSE OF DIFF. STEM DIRECTIONS.
50800 ; NEXT ADJUSTS STEMS WHEN BEAMS ARE USED.
50900 SETOM POSI+=8 ;197 JJ2=-1
51000 MOVE R,.COMM. ;R3=R2
51100 MOVEM R,DPYNEW
51200 FIXX(R)
51300 ;; MOVE STF+3(R) ;RSTJ2
51400 ;; MOVEM STF+10
51500 ;; LATER, BECAUSE OF 'AD 99' MOVEM R,.COMM.+3 ;J2=STF#
51600 MOVE IZ,[6.0]
51700 SETZ K, ;DO 191 K=1,ITEM
51800 H191: MOVEM K,LOOP ;SAVE K L=PWDS(K)
51900 MOVE L,PTR(K) ; L IS PWDS(K+1)
52000 ;IF(RN(L+1).NE.6)GO TO 191 -- NO ADJUSTMENT IF P10.NE.0
52100 MOVEI R,XRN(L)
52200 CAME IZ,(R)
52300 JRST HX191
52400 MOVE JK,DPYNEW ;IF(RN(L+2).EQ.R3)GO TO 77
52500 CAMN JK,1(R)
52600 JRST H77
52700 CAMGE JK,[=5.0] ;IF(R3.LT.5.)GO TO 191
52800 JRST HX191 ; TYPE AD 99 FOR ALL STAVES (=19 99)
52900 H77: MOVE JK,-1(R) ;77
53000 CAMN JK,[=8.0] ;IF(RN(L).EQ.8)GO TO 191
53100 JRST HX191
53200 MOVE JK,6(R) ;IF(RN(L+7).LT.10.)GO TO 191
53300 CAMGE JK,[=10.0] ;C FINDS BEAMS.
53400 JRST HX191
53500 FDVR JK,[=10.0] ;X=RG/10.
53600 FIXX(JK) ;C STEM DIRECT.
53700 MOVEM JK,XNOTE ;X SAVED IN XNOTE=STEM DIR.
53800 MOVE JK,1(R) ;R2=RN(L+2)
53900 MOVEM JK,.COMM. ; USED IN 'FINDIT'
54000 MOVE A,2(R) ;A=RN(L+3)-.01
54100 FSBR A,[=0.01]
54200 MOVEM A,NEWR ;SAVE A IN NEWR
54300 MOVM RC,3(R) ;RC=ABS(RN(L+4)) RC USED AFTER H192
54400 FSBR RC,[90.0] ;NEG=MAXI SIZE, POS=MINI SIZE BEAMS.
54500 MOVE JK,5(R) ;B=RN(L+6)+.01
54600 FADR JK,[=0.01] ;C POS 1 AND 2
54700 MOVEM JK,BAUTO ;B SAVED IN BAUTO
54800 FSBR JK,A ;DISX=B-A
54900 MOVEM JK,UPDATE ;DISX SAVED IN UPDATE
55000 ; DISTANCE IN REAL STEPS
55100 MOVEM R,NALF ;SAVE LOC OF RN(L+1)
55200 MOVE 0,3(R)
55300 MOVEM 0,JUGGLE
55400 JSA 16,AMOD ;RF=AMOD(RN(L+4),100.0)
55500 JUMP JUGGLE
55600 JUMP [=100.0]
55700 MOVEM 0,JUGGLE; THIS IS RF!!!!
55800 ; NOTE 2
55850 KIFIX JK,1(R) ;J2=RN(L+2) THE STF#
55875 MOVEM JK,.COMM.+3
55880 MOVE STF+3(JK) ;RSTFAC(JK) --- RSTJ2
55885 MOVEM STF+10
55900 MOVE JK,NALF
56000 MOVE JK,4(JK)
56100 MOVEM JK,MSSLUP
56200 JSA 16,AMOD ;RB=AMOD(RN(L+5),100.0)
56300 JUMP MSSLUP
56400 JUMP [=100.0] ;0 WILL HAVE RB!!!
56500 FSBR 0,JUGGLE
56600 MOVEM 0,SORT2 ;RD SAVED IN ALF+=9 -- RD=RB-RF
56700 MOVEI NX,1
56800 H192: JSA 16,FINDIT ;IF(FINDIT(N))GO TO 192
56900 JUMP NX
57000 JUMPL 0,HX192
57100 MOVEI R,XRN ;IF(RN(L).EQ.8)GO TO 192
57200 ADD R,PTR+=251 ;LOC OF RN(L+1)
57300 ;; MOVE JK,-1(R)
57400 ;; CAMN JK,[=8.0]
57500 ;; JRST HX192
57600 JUMPGE RC,.+4 ;JUMP IF MINI-BEAMS. THEY WILL LOOK FOR MININOTES
57700 MOVE JK,7(R) ;IF(RN(L+8).GE.1000.)GO TO 192
57800 CAML JK,[=1000.0]
57900 JRST HX192 ; SKIPS SLASHED GRACE NOTES (P8=1000 OR P10=1)
58000 ; FINDIT IS NEG. IF(RN(L+1).NE.1.OR.RN(L+3))
58100 MOVE A,2(R) ;RC=RN(L+3)
58200 SETZM STFLG# ;FOR NOTES ON DIF. STF. (P10=1↓, =2↑)
58300 MOVE -1(R) ;IF(RN(L).LT.8)GO TO HX4
58350 CAMGE [8.0]
58375 JRST HX4
58400 ;; SKIPG =9(R) ;IF(P10.LE.0)GO TO HX4
58500 ;; JRST HX4 ; NO
58520 SKIPGE MM,=9(R)
58540 JRST HX192
58560 JUMPE MM,HX4
58600 MOVE IEND,STF+10 ; GET RSTJ2
58605 KIFIX MM,MM ;MUST BE FIXED FOR COMPARES.
58610 MOVEM MM,STFLG ; STFLG HAS 1 ↓ OR 2 ↑
58620 CAMN MM,XNOTE ; IS IT ON STAFF BELOW (P10 =1)
58630 JRST HX4 ;IF(STEMDIR.EQ.STFLG)GO TO HX4
58700 SKIPL RC ; IS IT A MINI?
58800 FMPR IEND,[0.6] ; YES, *.6
58900 MOVE IS,[2.44] ; 2.44 IS NOTE WIDTH
59000 FMPR IS,IEND ; *RMINI
59150 CAME MM,[1.0]
59200 MOVNS IS ; NEG. NOTE WIDTH
59300 MOVE MM,NALF ; GET LOC OF RN(L+1) P1 OF THE BEAM
59400 MOVM MM,6(MM) ; MM=P7, NUMB OF BEAMS
59500 JSA 16,AMOD ; GO FIND SECOND DIGIT.
59600 JUMP MM
59700 JUMP [10.0]
59800 MOVE MM, ; GET THE RESULT INTO RIGHT AC
59900 FSBR MM,[1.0] ; LESS 1
60000 FMPR MM,[1.571429] ; *SPACE BETWEEN BEAMS
60050 MOVEM MM,BOX
60100 ;;; FMPR MM,IEND ; *RMINI
60300 FADR A,IS ; ADD OR SUB. NOTE WIDTH TO POS.
60400 ;; MOVE 5(R);; ;; ;GET P6
60500 ;; CAMGE [10.0];; ;; ;IF(P6.LT.10)GO TO HX4
60600 ;; JRST HX4
60700 ;; MOVE JK,[2.44];; ;; ; THE SIZE OF A NOTE
60800 ;; MOVE L,1(R);; ;; ; GET STAFF #
60900 ;; FIXX(L)
61000 ;; FMPR JK,STF+3(L);; ;*RSTFAC(L)
61100 ;; CAML [20.0];; ;; ;IF(P6.GE.20) SZ=-SZ
61200 ;; MOVNS JK
61300 ;; FADR A,JK;; ;; ;PUT SHIFTED POS. INTO A
61400 HX4: CAML A,NEWR ;IF(RC.LT.A)GO TO 192
61500 CAMLE A,BAUTO ;IF(RC.GT.B)GO TO 192
61600 JRST HX192 ; WHAT'S LEFT IS IN BEAM AREA IF STEM DIR. IS OK.
61700 ;; MOVE JK,4(R) ;IF(X.NE.IFIX(RN(L+5)/10.))GO TO 192
61800 KIFIX JK,4(R) ;FIXX(JK)
61900 IDIVI JK,=10
62000 SKIPE STFLG ; SKIP IF NOTE IS ON DIFF. STAFF
62100 JRST .+3
62200 CAME JK,XNOTE ;JK IS STEM DIR. OF NOTE; XNOTE, FOR BEAM
62300 JRST HX192
62400 FSBR A,NEWR ;RC=RC-A
62500 MOVEM A,MVBEAM;SAVES RC
62600 MOVEM R,MVBX ;SAVE LOC OF RN(L+1)
62700 MOVE 0,3(R)
62800 MOVEM 0,MSSLUP
62900 JSA 16,AMOD ;193 RE=AMOD(RN(L+4),100.0)
63000 JUMP MSSLUP
63100 JUMP [=100.0]
63200 MOVEM 0,ALF+3 ;RE SAVE HERE
63300 SKIPN MM,STFLG ; IF(STFLG.EQ.0)GO TO H577
63400 JRST H577
63500 MOVEI IS,1 ; IS=1
63600 CAIE JK,2 ; IF(JK.NE.2)IS=-1 -- STEM ↑ =1
63700 SETO IS,
63800 MOVE R,.COMM.+3 ;NN=(STFF(R+IS)-STFF(R))/7.
63900 MOVN NN,POSI+3(R)
64000 ADD R,IS
64100 FADR NN,POSI+3(R)
64200 MOVE [7.0]
64300 FMPR IEND ; 7*RMINI
64400 FDVR NN,
64500 MOVMS NN ; ABS VALUE
64520 CAME MM,XNOTE ;IF(STEMDIR.NE.XNOTE)STML=STML+13.714
64600 FSBR NN,[13.714] ; -2:STEM LENGTH
64700 ;; FDVR NN,IEND ; /RMINI
64800 ;; CAIN JK,1 ; IF(JK.EQ.1)NN=-NN
64900 ;; MOVNS NN
65000 H577: MOVE JK,SORT2 ;RC=RD*RC/DISX+RF
65100 FMPR JK,MVBEAM ;*RC
65200 FDVR JK,UPDATE ;/DISX
65300 FADR JK,JUGGLE ;+RF
65400 MOVEM JK,MVBEAM ;RC=
65500 MOVE JK,MVBX
65600 MOVE JK,6(JK) ;RG=RN(L+7)
65700 MOVEM JK,ALF+4 ;SAVE RG
65800 JSA 16,AMOD ;RN(L+7)=RG-AMOD(RG,10.0)+AMOD(RG,1.0)
65900 JUMP ALF+4
66000 JUMP [=10.0]
66100 MOVEM 0,LUP2
66200 JSA 16,AMOD
66300 JUMP ALF+4
66400 JUMP [=1.0]
66500 FSBR 0,LUP2
66600 FADR 0,ALF+4
66700 MOVE L,MVBX
66800 MOVEM 0,6(L) ;DELETES TAILS WITHOUT REMOVING DOTS OR SPACING OF DOTS.
66900 ; FRACTIONAL NOTE #
67000 MOVE R,MVBEAM ;195 RA=RC-RE
67100 FSBR R,ALF+3
67200 MOVE JK,XNOTE ;IF(X.EQ.2)RA=-RA
67300 CAIN JK,2
67400 MOVNS R
67500 ;; SKIPN R ;IF(RA.EQ.0)RA=999.
67600 ;; MOVE R,[=999.0]
67700 MOVE 0,7(L) ;IF(RN(L+8).GT.999)RA=RA+1000. FOR MINI-NOTES
67800 CAMLE 0,[999.0]
67900 FADR R,[1000.0]
68000 SKIPN MM,STFLG ; IF(STFLG.EQ.0)GO TO HX192-3
68100 JRST HX192-3 ; NEXT FOR NOTES ON DIFF. STF.
68110 CAME MM,XNOTE ;ARE STEM DIRS. SAME?
68120 JRST .+3 ;NO, JUMP
68130 FADR R,NN ;ADD UP FOR STEM LENGTH IF SAME DIR.
68140 JRST HX192-3 ; ALL DONE
68200 FSBR R,NN ;R=R-NN
68300 MOVNS R ;MAKE IT POS.
68400 FADR R,BOX ; ADD SPACE FOR MULTIPLE BEAMS
68500 MOVEM R,7(L) ;196 RN(L+8)=RA
68600 ; FRACTIONAL NOTE # - FIRST NOTE OF GROUP + THIS NOTE # ALL *7.
68700 SKIPGE POSI+=8
68800 MOVEM NX,POSI+=8 ; SAVES # OF LOWEST ITEM FOUND
68900 HX192: CAMGE NX,PTR+=250 ;192 CONTINUE
69000 AOJA NX,H192
69100 HX191: MOVE K,LOOP ;191 CONTINUE
69200 CAMGE K,PTR+=250
69300 AOJA K,H191
69400 JRA 16,(16) ;RETURN
69500 H9: SKIPGE .COMM.+=32 ;9 IF(J11.LT.0)RETURN
69600 JRA 16,(16) ; IF P11=-1 NO HOMING
69700 MOVM R,.COMM.+=28 ; X=IABS(J7)/10 CC X=R7/10.
69800 IDIVI R,=10 ;;;FDVR R,[=10.0]
69900 ;;; FIXX(R)
70000 ;;; SKIPGE R ;IF(X)X=-X
70100 ;;; MOVNS R
70200 MOVEM R,XNOTE ;X SAVED IN XNOTE-STEM DIR.
70400 ;;; MOVE L,.COMM.+=10 ;RA=R9
70500 ; R9= POS3
70600 MOVNI RC,1 ;RC=-1
70700 SKIPE .COMM.+=10 ;IF(R9.NE.0)RC=-2
70800 MOVNI RC,2
70900 MOVE JK,.COMM.+=31 ;IF(J10/10.EQ.3)RC=-3
71000 IDIVI JK,=10 ;JT HAS REMAINDER (AC4)
71100 CAIN JK,3
71200 MOVNI RC,3 ; RC=0 ESCAPES FRCOM LOOP.
71300 ;;; JRST HZ10
71400 ;;;H10: SETZ RC, ;FOR P13=1
71500 ; HOMING RANGE FOR BEAMS
71600 ;;;HZ10: MOVE IS,.COMM.+=12 ;10 IF(R11.EQ.0)R11=2.9
71700 H10: MOVE IS,.COMM.+=12 ;10 IF(R11.EQ.0)R11=2.9
71800 JUMPN IS,HX10
71900 MOVE IS,[=2.9]
72000 MOVEM IS,.COMM.+=12 ; IF P11.NE.0 RANGE IS CHANGED FROM 2
72100 HX10: MOVE IZ,.COMM.+1 ; IF(JA.EQ.5)RC=-1
72200 CAIN IZ,5
72300 MOVNI RC,1
72400 MOVEI K,1
72500 MOVE L,.COMM.+1 ; JA IS NOW IN L
72600 H361: JSA 16,FINDIT ;DO 361 K=1,ITEM
72700 JUMP K
72800 JUMPL 0,HX361 ;IF(FINDIT(K))GO TO 361
72900 ; SKIPS NOTES ON WRONG LINE
73000 MOVEI R,XRN ;RD=RN(L+3)
73100 ADD R,PTR+=251 ;LOC OF RN(L+1)
73200 MOVE A,2(R) ;RD IN A
73300 MOVEM A,RMOD+=9 ;1 IF(JA.NE.6)GO TO 177
73400 MOVE JK,4(R) ;IF(IFIX(RN(L+5)/10).NE.X)GO TO 361
73500 CAIE L,6
73600 JRST H177
73700 FIXX(JK)
73720 IDIVI JK,=10 ;JK=NOTE'S STEM DIRECTION
73738 MOVE -1(R)
73756 CAML [8.0]
73774 SKIPN JT, =9(R) ;JT='OTHER STAFF' INFO 2=↑ 1=↓
73783 JRST H377 ;IF(RN(L+10).EQ.0)GO TO H377
73787 KIFIX JT,JT ;FIX IT FOR COMPARE.
73792 CAMN JT,XNOTE ;IF(STEM DIRS. ARE SAME)GO TO H377
73813 JRST H377
73816 MOVE 1,[2.44]
73817 FMPR 1,STF+=8 ;*RSTJ2
73818 MOVM NN,.COMM.+=25 ;IF(ABS(J4.GE.100) *.6 (MINI)
73819 CAIL NN,=90
73820 FMPR 1,[0.6]
73826 CAIE JK,1
73845 MOVNS 1
73850 FADR A,1 ; ADD OR SUB. NOTE WIDTH FROM NOTE POS.
73875 JRST H177 ;ALL NOTES ON 'DIFF. STF' ARE CONSIDERED.
73900 H377: CAME JK,XNOTE
74000 JRST HX361
74100 H177: JSA 16,PLACE ;177 IF(PLACE(R3))GO TO 461
74200 JUMP .COMM.+4
74300 JUMPL H461
74400 SETOM IZ
74500 HX2: MOVE 5(R) ;GET PARAM 6
74600 CAMGE [10.0] ; MUST BE .GE.10
74700 JRST HX1
74800 MOVE IS,[2.44] ; SIZE OF A NOTE
74900 CAML [20.0] ; 10 = RIGHT SHIFT, 20 = LEFT SHIFT
75000 MOVNS IS
75100 MOVM 3(R) ; GET P4
75200 CAML [100.0] ; IS IT A MINI?
75300 CAML [200.0]
75400 SKIPA
75500 FMPR IS,[0.6] ;*RMINI
75600 MOVE 1,.COMM.+3 ;STAFF #
75700 FMPR IS,STF+3(1) ;*RSTFAC(J2)
75800 FADR A,IS
75900 HX1: JUMPG IZ,HX8 ; JUMP TO CHANGE P6, 8 OR 9
76000 HX3: MOVEM A,.COMM.+4 ;R3=RD
76100 ; LOOKS FOR NOTE, STAFF #, STEM DIR.
76200 MOVN .COMM.+=14 ;P13=-1 HOME TO NOTE SIDE, =-2 TO STEM.
76300 SKIPG ;IS IT NEG.
76400 JRST H11 ; NO, GO TO NEXT SECTION.
76500 MOVE IS,3(R) ; VERTICAL POS OF NOTE (P4)
76600 CAME [1.0] ;IS P13 -1 OR -2?
76700 JRST H12 ;IT'S -2
76800 MOVE [2.0]
76900 CAMGE JK,[20.0] ;WHICH WAY IS STEM?
77000 MOVNS
77100 FADR IS ;ADD NOTE LEVEL
77200 MOVEM .COMM.+5 ;P4=NOTE LEVEL + OR - 2.
77300 JRST H11
77400 H12: MOVE IZ,7(R) ; STEM LENGTH
77500 CAMN IZ,[999.0] ; WHAT ABOUT 16TH AND 32ND NOTES??
77600 SETZ IZ,
77700 FADR IZ,[8.0]
77800 JSA 16,AMOD
77900 JUMP 6(R)
78000 JUMP [10.0] ;AC0=AMOD(R7,10.0)
78100 SKIPN
78200 JRST H13
78300 FSBR [1.0] ;IGNORE 1ST TAIL
78400 FMPR [1.8] ; *SPACE FOR EACH TAIL
78500 FADR IZ, ; ADD TO STEM LENGTH
78600 H13: CAML JK,[20.0]
78700 MOVNS IZ ;PUT IT UPSIDE DOWN.
78800 FADR IS,IZ ;ADD NOTE LEVEL
78900 MOVEM IS,.COMM.+5 ;PUT IT BEYOND STEM
79000 H11: CAIN L,6 ;IF(JA.EQ.6)GO TO 861
79100 JRST H861
79200 CAIN L,5 ;IF(JA.EQ.5)GO TO 261
79300 JRST H261
79400 JRA 16,(16) ;RETURN
79500 H461: CAIN L,6 ;461 IF(JA.EQ.6)GO TO 277
79600 JRST H277
79700 CAIE L,5 ;IF(JA.NE.5)GO TO 361
79800 JRST HX361
79900 H277: JSA 16,PLACE ;277 IF(PLACE(R6))GO TO 561
80000 JUMP .COMM.+7
80100 JUMPL H561
80200 MOVEI IZ,7 ;R6=RD
80300 JRST HX2
80400 H861: MOVE 0,.COMM.+=28 ;861 IF(J7.GE.0)GO TO 261
80500 JUMPGE 0,H261
80600 H561: JSA 16,PLACE ;561 IF(PLACE(R9))GO TO 661
80700 JUMP .COMM.+=10 ;R9
80800 JUMPL H661
80900 MOVE 0,.COMM.+=28 ;IF(J7)GO TO 761
81000 JUMPL H761 ; J7=NEG MEANS TREMOLO
81100 MOVE 0,.COMM.+=9 ; IF(R8.NE.0)GO TO 761
81200 JUMPN H761
81300 MOVE 0,.COMM.+=11 ; IF(R10.EQ.0)GO TO 361
81400 JUMPE HX361
81500 H761: MOVEI IZ,=10 ;761 R9=RD
81600 JRST HX2
81700 ; R8=0, R10=0 MEANS R9 IS NUMBER OUTSIDE OF BEAM. ; GO TO 261
81800 H661: CAIN L,5 ;661 IF(JA.EQ.5)GO TO 361
81900 JRST HX361
82000 MOVE 0,.COMM.+=31 ;IF(J10.LT.30)GO TO 361
82100 CAIGE 0,=30
82200 JRST HX361
82300 JSA 16,PLACE ;IF(PLACE(R8))GO TO 361
82400 JUMP .COMM.+=9
82500 JUMPL HX361 ; HOMES INNER PARTIAL BEAMS
82600 MOVEI IZ,=9 ;R8=RD
82700 JRST HX2
82800 HX8: MOVEM A,.COMM.(IZ) ;PUT A INTO RIGHT PARAM.
82900 H261: SKIPN RC ;261 IF(RC.EQ.0)RETURN
83000 JRA 16,(16)
83100 AOJ RC ;RC=RC+1
83200 HX361: CAMGE K,PTR+=250 ;361 CONTINUE
83300 AOJA K,H361
83400 JRA 16,(16) ; END
84600
84700 FSCAN: 0
84800 INCHRW
84900 MOVE 2,[ASCII/ /]
85000 MOVEM 2,ALF
85100 MOVE 2,[XWD ALF,ALF+1]
85200 BLT 2,ALF+=71 ; CLEANS OUT INP ARRAY
85300 CAIN ";"
85400 JRA 16,(16)
85500 CAIN ":"
85600 JRA 16,1(16)
85700 CAIN "("
85800 JRA 16,2(16)
85900 CAIN ")"
86000 JRA 16,3(16)
86100 CAIN "/"
86200 JRA 16,4(16)
86300 CAIN "*"
86400 JRA 16,5(16)
86500 CAIN "X"
86600 JRA 16,6(16)
86700 CAIN "C"
86800 JRA 16,7(16)
86900 JRA 16,8(16)
87000
87100
87200 NALF: 0
87300 MOVE 0,@(16)
87400 JUMPGE .+4 ;IF(I.GE.0)GO TO 20
87500 MOVE 1,[405004020100] ; J='A'=405004020100
87600 SETO 2, ; M=-1
87700 JRST .+3 ;GO TO 10
87800 MOVE 1,[201004020100] ;20 J=' '=201004020100
87900 MOVEI 2,=16 ; M=16
88000 SUB 0,1 ;10 NALF=(I-J)/536870912-M
88100 IDIV 0,[3777777777]
88200 SUB 0,2
88300 JRA 16,1(16)
88400
88500 BOX: 0 ;CALL BOX(I,R) SEE PLTSRT.F4 FOR FORTR. VERSION
88600 MOVE 14,@(16) ; I IS IN 14
88700 JUMPL 14,BX4
88800 KIFIX 13,@1(16) ;MOVE 13,@1(16) ; GET R
88900 ;; FIXX(13) ; K=R
89000 JSA 16,AMOD
89100 JUMP XRN+3(14) ; GET REAL P4
89200 [100.0]
89300 FMPR [7.0]
89400 FMPR STF+3(13) ;*STAFF FACTOR
89500 FADR POSI+3(13) ; + STAFF VERT. POS.
89600 FSBR [40.0] ; SHIFT CURSOR DOWN A BIT.
89700 FMPR SIZ
89800 KIFIX 13,0 ;MOVE 13,
89900 ;; FIXX(13)
90000 SUB 13,SIZ+2 ;13=K
90100 JSA 16,RHORZ ; GET HORIZ. POS.
90200 JUMP XRN+2(14)
90300 FMPR SIZ ;SIZ IS FOR ZOOMED IMAGES
90400 KIFIX 12,0 ;MOVE 12, ; 12=L
90500 ;; FIXX(12)
90600 SUB 12,SIZ+1
90700 CAIL 12,=550 ; CHECK IF OUT OF BOUNDS OF CRT
90800 MOVEI 12,=511
90900 CAMG 12,[-=550]
91000 MOVE 12,[-=511]
91100 JSA 16,SETCUR
91200 12
91300 13
91400 [0]
91500 JRA 16,2(16) ; THE CURSOR IS IN POSITION
91600 BX4: CAME 14,[-1]
91700 JRST BX5
91800 JSA 16,DPYSET
91900 [3]
92000 RINP
92100 [=100]
92200 JSA 16,DPYBRT
92300 [3]
92400 BX5: MOVE 2,@1(16) ; GET R
92500 JSA 16,RHORZ
92600 2
92700 FMPR SIZ
92800 FIXX(0)
92900 SUB SIZ+1
93000 MOVM 2,
93100 CAILE 2,=550
93200 JRST BX6
93300 MOVEM 0,LOOP
93400 JSA 16,SETPOG
93500 [3]
93600 JSA 16,ALINE
93700 LOOP
93800 [-=511]
93900 LOOP
94000 [=511]
94100 JSA 16,DPYOUT
94200 [3]
94300 BX6: JSA 16,SETPOG
94400 [1]
94500 JRA 16,2(16)
94600
94700 END